home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / basic / basconv.com / BASCONV.BAS next >
Encoding:
BASIC Source File  |  1983-06-11  |  18.4 KB  |  444 lines
  1. 10 REM    IBM-PC BASIC-TO-FORTRAN CONVERTER V. 1.0
  2. 20 REM       COPYRIGHT (C) JIM GLASS, MAY 1983
  3. 30 REM      * NOT FOR SALE * THIS SOFTWARE IS
  4. 40 REM       IN THE PUBLIC DOMAIN AND IS FREE
  5. 50 REM    FOR USE, MODIFICATION, AND DISTRIBUTION
  6. 60 REM
  7. 1000 DEFINT A-Z
  8. 1050 DEF FNUM(Q$)=ASC(LEFT$(Q$,1))>47 AND ASC(LEFT$(Q$,1))<58
  9. 1100 DEF FNTOGGLE(X$,Y$,FLG)=FLG XOR X$=Y$
  10. 1150 DEF FNREP$(X$,Y$,A,B)=LEFT$(X$,A-1)+Y$+MID$(X$,B)
  11. 1200 DEF FNINS$(X$,Y$,A,B)=LEFT$(X$,A)+Y$+MID$(X$,B)
  12. 1250 TST$(1)="$":TST$(2)="%":TST$(3)="#":TST$(4)="!"
  13. 1300 DIM REFLIN!(500),VALPH$(200),VINT$(200),VDBL$(200),VSNGL$(200)
  14. 1350 DIM POINT4!(200,2),STACK4(25),CSTK$(25),TOKLST$(20),PTLST(20),AA(20),BB(20)
  15. 1400 DATA " ","(",")","^","*","-","+","=","<",">"
  16. 1450 RESTORE 1400:FOR I=1 TO 10:READ DELIM$(I):NEXT
  17. 1550 NEXTLIN!=0
  18. 1600 NN=71
  19. 1601 KEY OFF
  20. 1650 IREF=0:JREF=0:IINT=0:IALPH=0:IDBL=0:ISNGL=0
  21. 1700 TRUE=-1:FALSE=0:PT4=0
  22. 1750 IMPFLG=FALSE:XORFLG=FALSE:EQVFLG=FALSE
  23. 1800 REM
  24. 1850 DIM KFOR$(80),PNTR(1150)
  25. 1900 DIM KBAS$(80),TWOS(6)
  26. 1950 DIM BUF$(10),CP(10)
  27. 2000 DATA ABS,AND,ASC,ATN,BEEP,CDBL,CHR$,CINT,CLOSE,CLS,COMMON
  28. 2050 DATA COS,CSNG,DATA,DEF,DEFSNG,DEFDBL,DEFINT,DEFSTR,DIM,ELSE,END
  29. 2100 DATA EOF,EQV,EXP,FIX,FN,FOR,GOSUB,GOTO,IF,IMP,INKEY$,INPUT
  30. 2150 DATA INPUT#,INPUT$,INT,LET,LOG,LPRINT,MOD,NEXT,NOT,ON,OPEN,OPTION
  31. 2200 DATA OR,PRINT,PRINT#,READ,REM,RESTORE,RETURN,SGN,SIN,SPACE$
  32. 2250 DATA SPC(,SQR,STEP,STOP,SWAP,TAN,THEN,then,TO,USING,WEND,WHILE,WRITE
  33. 2300 DATA WRITE#,XOR
  34. 2350 REM unhandled:data,gosub,inkey$,input$,option,read,restore,space$,spc(
  35. 2400 REM
  36. 2450 DATA 1,2,4,8,16,32
  37. 2500 REM
  38. 2550 REM
  39. 2600 DATA ABS,.AND.,ICHAR,ATAN,*,DBLE,CHAR,ANINT,CLOSE(,*,COMMON
  40. 2650 DATA COS,SNGL,DATA,*,IMPLICIT REAL (,IMPLICIT REAL*8 ( ,IMPLICIT INTEGER ( ,CHARACTER*127,DIMENSION,ELSE,END
  41. 2700 DATA EOF,*,EXP,IFIX,*,DO,CALL,GOTO,IF(,*,*,"READ(*,*)"
  42. 2750 DATA "READ(*,*)",READ,INT,*,ALOG,"WRITE(6,*)",MOD,CONTINUE,.NOT.,ON,OPEN,*
  43. 2800 DATA .OR.,"WRITE(*,*)",WRITE,*,C,*,RETURN,SIGN,SIN,*
  44. 2850 DATA *,SQRT,",",STOP,*,TAN,],] THEN,",",",",*,CONTINUE,"WRITE(*,*)",WRITE,*
  45. 2900 REM
  46. 2950 RESTORE 2000
  47. 3000 FOR I=1 TO NN:READ X$:KBAS$(I)=SPACE$(8):LSET KBAS$(I)=X$:NEXT
  48. 3050 RESTORE 2450:FOR I=1 TO 6:READ TWOS(I):NEXT
  49. 3100 RESTORE 2600:FOR I=1 TO NN:READ X$:KFOR$(I)=X$:NEXT
  50. 3150 FOR I=1 TO NN
  51. 3200 TOKEN$=KBAS$(I)
  52. 3250 GOSUB 6900
  53. 3350 IF PNTR(S)=0 THEN PNTR(S)=I
  54. 3400 NEXT I
  55. 3450 PRINT"Enter name of BASIC   Program ";:INPUT F$
  56. 3500 OPEN F$ FOR INPUT AS #1
  57. 3550 PRINT "Enter name of FORTRAN Program ";:INPUT G$
  58. 3600 OPEN G$ FOR OUTPUT AS #2
  59. 3650 PRINT "Do you wish to have source displayed? ";:INPUT X$
  60. 3700 PRINT
  61. 3750 IF LEFT$(X$,1)="Y" OR LEFT$(X$,1)="y" THEN SHOW=TRUE ELSE SHOW=FALSE
  62. 3800 IF SHOW THEN CLS
  63. 3850 ON ERROR GOTO 6850
  64. 3900 H$="c:WORK":OPEN H$ FOR OUTPUT AS #3: GOTO 4000
  65. 3950 H$="b:WORK":OPEN H$ FOR OUTPUT AS #3
  66. 4000 ON ERROR GOTO 0
  67. 4001 OLIN=0
  68. 4002 LOCATE 2,50:COLOR 5,0:PRINT"PASS 1: PARSING"
  69. 4050 FOR Z!=1 TO 1000000!
  70. 4100 IF EOF(1) THEN 6101
  71. 4150 IF INSTR(BUF$(0),"XOR")<>0 THEN XORFLG=TRUE
  72. 4200 IF INSTR(BUF$(0),"IMP")<>0 THEN IMPFLG=TRUE
  73. 4250 IF INSTR(BUF$(0),"EQV")<>0 THEN EQVFLG=TRUE
  74. 4300 LINE INPUT#1,BUF$(0)
  75. 4350 FC=INSTR(1,BUF$(0)," ")+1
  76. 4400 I=1:LLINES=1:OLIN=OLIN+1:QUOTFLG=FALSE
  77. 4450 CM=0
  78. 4500 REM
  79. 4550 REM fix ELSEs
  80. 4600 REM
  81. 4650 GOSUB 7800:L=LEN(BUF$(0))
  82. 4700 P=0:FOR J=I TO L:X$=MID$(BUF$(0),J,1):QUOTFLG=FNTOGGLE(X$,CHR$(34),QUOTFLG)     :IF (NOT QUOTFLG) AND X$=":" THEN P=J:GOTO 4800
  83. 4750 NEXT J
  84. 4800 IF P=0 THEN P=(INSTR(FC,BUF$(0),"'"))-FC:IF P>0 THEN CM=LLINES
  85. 4850 IF P>0 THEN CP(LLINES)=P:LLINES=LLINES+1:OLIN=OLIN+1:I=P+1-(CM<>0):GOTO         4700 ELSE GOTO     4900
  86. 4900 CP(LLINES)=L+1:CP(0)=0
  87. 4950 REM
  88. 5000 FOR M=LLINES TO 1 STEP-1
  89. 5050 BUF$(M)=MID$(BUF$(0),CP(M-1)+1,CP(M)-CP(M-1)-1-(CM=M))
  90. 5100 NEXT
  91. 5150 LINEO!=VAL(BUF$(1)):IF LINEO!<=NEXTLIN! THEN PRINT"ERROR":BEEP:STOP
  92. 5200 IF LLINES<2 THEN 5300
  93. 5250 FOR K=2 TO LLINES:NEXTLIN!=LINEO!-1+K:L$=STRING$(5," "):BUF$(K)=L$+" "         +BUF$(K):NEXT
  94. 5300 IF FC=7 THEN 5400
  95. 5350 BUF$(1)=LEFT$(BUF$(1),FC-1)+" "+MID$(BUF$(1),FC):FC=FC+1:GOTO 5300
  96. 5400 RMFLG=FALSE
  97. 5450 FOR I=1 TO LLINES 'for each logical line...
  98. 5500 IF MID$(BUF$(1),FC,3)="REM" OR MID$(BUF$(1),FC,1)="'" THEN RMFLG=TRUE
  99. 5550 IF (NOT RMFLG) AND MID$(BUF$(I),FC,1)="'" THEN BUF$(I)="C"+BUF$(I)
  100. 5600 IF RMFLG THEN BUF$(I)="C"+BUF$(I)
  101. 5650 NEXT
  102. 5700 IF RMFLG THEN 5950
  103. 5750 ON ERROR GOTO 13000
  104. 5800 GOSUB 8300 'BUILD TABLE OF REFERENCED LINES
  105. 5850 GOSUB 9500 'BUILD TABLE OF CHAR, INT, AND DBL VARS [SINGLE NOT DETECTABLE]
  106. 5900 GOSUB 11950 'BUILD FOR/NEXT REF TABLE
  107. 5950 FOR I=1 TO LLINES:PRINT#3,BUF$(I)
  108. 6000 IF SHOW THEN COLOR 3,1:PRINT BUF$(I):COLOR 7,0
  109. 6050 BUF$(I)="":NEXT I
  110. 6100 NEXT Z!
  111. 6101 GOSUB 30000
  112. 6150 CLOSE 1:CLOSE 3:OPEN H$ FOR INPUT AS #1
  113. 6200 IF SP<>0 THEN ERROR 82
  114. 6250 IF SHOW THEN PRINT
  115. 6300 LOCATE 2,50:COLOR 3,0:PRINT"PASS 2: EDITING "
  116. 6350 GOSUB 13200 'VAR DEFS
  117. 6351 LOUT=0
  118. 6400 WHILE NOT EOF(1)
  119. 6450 LINE INPUT#1,BUF$(0)
  120. 6451 LOUT=LOUT+1
  121. 6452 IF OLIN>20 AND (LOUT MOD 20)=0 OR LOUT=1 THEN CLS:GOSUB 30000:LOCATE 2,50:      COLOR 3,0:PRINT     "PASS 2: EDITING "
  122. 6500 FS=INSTR(BUF$(0)," "):LINEO!=VAL(LEFT$(BUF$(0),FS)):L$=MID$(STR$(LINEO!),2)
  123. 6550 X$=STRING$(6," "):IF LEFT$(BUF$(0),1)<>"C" THEN MID$(BUF$(0),1,6)=X$
  124. 6600 GOSUB 14350:GOSUB 21150:PRINT#2,BUF$(0)
  125. 6650 IF SHOW THEN COLOR 1,3:PRINT BUF$(0):COLOR 7,0
  126. 6700 WEND
  127. 6750 REM
  128. 6800 END
  129. 6850 RESUME 3950
  130. 6900 S=0
  131. 6950 FOR J=8 TO 1 STEP -1
  132. 7000 ZL=J
  133. 7050 X$=MID$(TOKEN$,J,1):IF X$<>" " THEN 7150
  134. 7100 NEXT J
  135. 7150 IF ZL>6 THEN ZL=6
  136. 7200 FOR J=1 TO ZL
  137. 7250 X$=MID$(TOKEN$,J,1):X=ASC(X$)-64
  138. 7300 S=S+X*TWOS(ZL-J+1)
  139. 7350 NEXT J
  140. 7400 S=S-23:IF S<0 OR S>1134 THEN S=0
  141. 7450 REM RESOLVE COLLISIONS
  142. 7500 IF TOKEN$="EOF     " THEN S=78:RETURN
  143. 7550 IF TOKEN$="SIN     " THEN S=79:RETURN
  144. 7600 IF TOKEN$="TO      " THEN S=80:RETURN
  145. 7650 IF TOKEN$="IMP     " THEN S=77:RETURN
  146. 7700 IF TOKEN$="INT     " THEN S=76:RETURN
  147. 7750 RETURN
  148. 7800 PE=FC:ELSC=0:IF INSTR(BUF$(0),"ELSE")=0 THEN RETURN
  149. 7850 ELSP=INSTR(PE,BUF$(0),"ELSE"):IF ELSP=0 THEN 8150
  150. 7900 ELSC=ELSC+1:ND=ELSP+4
  151. 7950 IF FNUM(MID$(BUF$(0),ND+1,1)) THEN BUF$(0)=FNINS$(BUF$(0),"GOTO ",ND,ND+1)
  152. 8000 BUF$(0)=FNINS$(BUF$(0),":",ELSP-1,ELSP):BUF$(0)=FNINS$(BUF$(0),":",ND,ND+1)
  153. 8050 IF INSTR(MID$(BUF$(0),PE,ELSP-PE),":")<>0 THEN BUF$(0)=FNINS$(BUF$(0),          ":ENDIF",ELSP-2,ELSP-1):ELSP=ELSP+6
  154. 8100 PE=ELSP+2:GOTO 7850
  155. 8150 FOR K=1 TO ELSC:BUF$(0)=BUF$(0)+":ENDIF":NEXT
  156. 8200 IT=INSTR(BUF$(0),"THEN"):BUF$(0)=FNREP$(BUF$(0),"then",IT,IT+4):RETURN
  157. 8250 REM
  158. 8300 T=1:FOR I=1 TO LLINES
  159. 8350 T=1
  160. 8400 IF INSTR(MID$(BUF$(I),1),"ON ERROR")=0 THEN 8500
  161. 8450 BUF$(I)="C"+BUF$(I):GOTO 9400
  162. 8500 Q=INSTR(T,BUF$(I),"GOTO "):IF Q=0 THEN Q=INSTR(T,BUF$(I),"GOSUB ")
  163. 8550 IF Q=0 THEN Q=INSTR(T,BUF$(I),"then ")
  164. 8600 IF Q<>0 THEN 9050
  165. 8650 T0=T:T=INSTR(T,BUF$(I),"THEN ")+5 'IF T=5 THEN T=INSTR(T0,BUF$(I),"then")+5     :IF T>5 THEN IFE=TRUE
  166. 8700 IF T=5 THEN T=LEN(BUF$(I))
  167. 8750 IF T=LEN(BUF$(I)) THEN 8950
  168. 8800 IF NOT FNUM(MID$(BUF$(I),T)) THEN 8950
  169. 8900 BUF$(I)=LEFT$(BUF$(I),T-1)+"GOTO "+MID$(BUF$(I),T):Q=T
  170. 8950 E=INSTR(T,BUF$(I),"ELSE ")+5:IF T=LEN(BUF$(I)) AND E=5 THEN 9400
  171. 9000 IF Q=0 THEN 9400
  172. 9050 N=INSTR(Q,BUF$(I)," ")+1
  173. 9100 M!=VAL(MID$(BUF$(I),N)):IF M!=0 THEN 9400
  174. 9150 FOR K=1 TO IREF:IF REFLIN!(K)=M! THEN 9300:NEXT
  175. 9200 IREF=IREF+1:REFLIN!(IREF)=M!
  176. 9250 JREF=JREF+1
  177. 9300 NN=INSTR(N,BUF$(I),",")+1:IF NN>N+1 THEN N=NN:GOTO 9100
  178. 9350 IF E>5 THEN T=E:GOTO 8750
  179. 9400 NEXT I
  180. 9450 RETURN
  181. 9500 FOR K=1 TO 4
  182. 9550 FOR I=1 TO LLINES
  183. 9600 P=1
  184. 9650 P=INSTR(P+1,BUF$(I),TST$(K)):IF P=0 THEN 10950
  185. 9700 T$="":FOR J=P-1 TO 1 STEP -1:X$=MID$(BUF$(I),J,1)
  186. 9750 IF(INSTR("=, +*/\()^:<>;-",X$)<>0) THEN 9900
  187. 9800 T$=X$+T$
  188. 9850 NEXT J
  189. 9900 TOKEN$=T$+TST$(K):IF LEN(TOKEN$)=1 THEN 9650
  190. 9950 IF LEN(TOKEN$)>=8 THEN 10000 ELSE TOKEN$=TOKEN$+" ":GOTO 9950
  191. 10000 GOSUB 6900:IF S<>0 AND TOKEN$=KBAS$(PNTR(S)) THEN P=P+1:GOTO 9650
  192. 10050 P=P+1
  193. 10100 ON K GOTO 10150,10350,10500,10700
  194. 10150 REM ALPHA
  195. 10200 FOR N=1 TO IALPH:IF T$=VALPH$(N) THEN 10650
  196. 10250 NEXT
  197. 10300 IALPH=IALPH+1:VALPH$(IALPH)=T$:GOTO 10650
  198. 10350 FOR N=1 TO IINT:IF T$=VINT$(N) THEN 10650
  199. 10400 NEXT
  200. 10450 IINT=IINT+1:VINT$(IINT)=T$:GOTO 10650
  201. 10500 FOR N=1 TO IDBL:IF T$=VDBL$(N) THEN 10650
  202. 10550 NEXT
  203. 10600 IDBL=IDBL+1:VDBL$(IDBL)=T$:GOTO 10650
  204. 10650 GOTO 9650
  205. 10700 REM single
  206. 10750 FOR N=1 TO ISNGL:IF T$=VSNGL$(N) THEN 10900
  207. 10800 NEXT
  208. 10850 ISNGL=ISNGL+1:VSNGL$(ISNGL)=T$:GOTO 10900
  209. 10900 GOTO 9650
  210. 10950 NEXT I
  211. 11000 NEXT K
  212. 11050 RETURN
  213. 11100 TP=0
  214. 11150 FOR K=1 TO 10
  215. 11200 P=1
  216. 11250 P=INSTR(P,BUF$(0),DELIM$(K)):IF P=0 THEN P=LEN(BUF$(0))+1
  217. 11300 T$="":FOR J=P-1 TO 1 STEP -1:X$=MID$(BUF$(0),J,1)
  218. 11350 IF(INSTR("=, +*/\()^:<>;-",X$)<>0) THEN 11500
  219. 11400 T$=X$+T$
  220. 11450 NEXT J
  221. 11500 TOKEN$=T$  'TOKEN$=T$+TST$(K)
  222. 11550 IF LEN(TOKEN$)>=8 THEN 11600 ELSE TOKEN$=TOKEN$+" ":GOTO 11550
  223. 11600 GOSUB 6900:IF S=0 OR TOKEN$<>KBAS$(PNTR(S)) THEN P=P+1:IF P<=LEN(BUF$(0))       THEN 11250 ELSE 11700
  224. 11650 TP=TP+1:TOKLST$(TP)=TOKEN$:AA(TP)=P-(J-1):BB(TP)=P:PTLST(TP)=PNTR(S):P=P+1      :IF P<=LEN(BUF$(0)) THEN 11250 ELSE 11750
  225. 11700 NEXT K
  226. 11750 FOR K=1 TO TP-1:FOR J=K+1 TO TP
  227. 11800 IF AA(J)>AA(K) THEN SWAP AA(J),AA(K):SWAP BB(J),BB(K):SWAP TOKLST$(J),          TOKLST$(K):SWAP PTLST(J),PTLST(K)
  228. 11850 NEXT J:NEXT K
  229. 11900 RETURN
  230. 11950 FOR I=1 TO LLINES
  231. 12000 LNO!=LINEO!+I-1:L2=LEN(BUF$(I))
  232. 12050 IF MID$(BUF$(I),FC,4)<>"FOR " THEN 12300
  233. 12100 PT4=PT4+1:POINT4!(PT4,1)=LNO!:POINT4!(PT4,2)=-PT4:SP=SP+1:STACK4(SP)=PT4
  234. 12150 IF SP<0 THEN ERROR 80 ELSE IF SP>25 THEN ERROR 81
  235. 12200 IF I=1 THEN 12300 ELSE L$=MID$(STR$(LNO!),2)
  236. 12250 GOSUB 20850:GOTO 12450
  237. 12300 IF MID$(BUF$(I),FC,5)="NEXT " OR (L2=FC+3 AND MID$(BUF$(I),FC,4)="NEXT")        THEN POINT4!(STACK4(SP),2)=LNO!:SP=SP-1 ELSE 12450
  238. 12350 IF I=1 THEN 12450 ELSE L$=MID$(STR$(LNO!),2)
  239. 12400 GOSUB 20850
  240. 12450 REM WHILE/WEND
  241. 12500 IF MID$(BUF$(I),FC,6)<>"WHILE " THEN 12750
  242. 12550 PT4=PT4+1:POINT4!(PT4,1)=LNO!:POINT4!(PT4,2)=-PT4:SP=SP+1:STACK4(SP)=PT4:       CSTK$(SP)=MID$(BUF$(I),FC+6)
  243. 12600 IF SP<0 THEN ERROR 80 ELSE IF SP>25 THEN ERROR 81
  244. 12650 IF I=1 THEN 12750 ELSE L$=MID$(STR$(LNO!),2)
  245. 12700 GOSUB 20850:GOTO 12900
  246. 12750 IF MID$(BUF$(I),FC,5)="WEND " OR (L2=FC+3 AND MID$(BUF$(I),FC,4)="WEND")        THEN POINT4!(STACK4(SP),2)=LNO!:BUF$(I)=BUF$(I)+" "+CSTK$(SP):SP=SP-1 ELSE      12900
  247. 12800 IF I=1 THEN 12900 ELSE L$=MID$(STR$(LNO!),2)
  248. 12850 GOSUB 20850
  249. 12900 NEXT I
  250. 12950 RETURN
  251. 13000 IF ERR=80 THEN PRINT"NEXT OR WEND WITHOUT FOR OR WHILE IN: ":PRINT BUF$(0)      :STOP
  252. 13050 IF ERR=81 THEN PRINT"TOO MANY NESTED LOOPS AT: ":PRINT BUF$(0):STOP
  253. 13100 IF ERR=82 THEN PRINT"FOR WITHOUT NEXT SOMEWHERE IN PROGRAM...":STOP
  254. 13150 PRINT ERR,ERL:STOP
  255. 13200 IF IALPH>0 THEN PRINT#2,"      CHARACTER*127 ";
  256. 13250 QL=7:CON=FALSE:FOR I=1 TO IALPH-1:QL=QL+LEN(VALPH$(I))+2
  257. 13300 IF QL<66 THEN PRINT#2,VALPH$(I)+"$"+","; ELSE QL=7:CON=TRUE:PRINT#2,            VALPH$(I)+"$"
  258. 13350 IF CON THEN PRINT#2,"     &";:CON=FALSE
  259. 13400 NEXT I:IF IALPH>0 THEN PRINT#2,VALPH$(IALPH)+"$"
  260. 13450 IF IINT>0 THEN PRINT#2,"      INTEGER ";
  261. 13500 QL=7:CON=FALSE:FOR I=1 TO IINT-1:QL=QL+LEN(VINT$(I))+2
  262. 13550 IF QL<66 THEN PRINT#2,VINT$(I)+"%"+","; ELSE QL=7:CON=TRUE:PRINT#2,             VINT$(I)+"%"
  263. 13600 NEXT I:IF IINT>0 THEN PRINT#2,VINT$(IINT)+"%"
  264. 13650 IF IDBL>0 THEN PRINT#2,"      REAL*8 ";
  265. 13700 QL=7:CON=FALSE:FOR I=1 TO IDBL-1:QL=QL+LEN(VDBL$(I))+2
  266. 13750 IF QL<66 THEN PRINT#2,VDBL$(I)+"#"+","; ELSE QL=7:CON=TRUE:PRINT#2,             VDBL$(I)+"#"
  267. 13800 NEXT I:IF IDBL>0 THEN PRINT#2,VDBL$(IDBL)+"#"
  268. 13850 IF ISNGL>0 THEN PRINT#2,"      REAL ";
  269. 13900 QL=7:CON=FALSE:FOR I=1 TO ISNGL-1:QL=QL+LEN(VSNGL$(I))+2
  270. 13950 IF QL<66 THEN PRINT#2,VSNGL$(I)+"#"+","; ELSE QL=7:CON=TRUE:PRINT#2,            VSNGL$(I)+"!"
  271. 14000 NEXT I:IF ISNGL>0 THEN PRINT#2,VSNGL$(ISNGL)+"!"
  272. 14050 IF EQVFLG THEN PRINT#2,"      LOGICAL FEQV"
  273. 14100 IF XORFLG THEN PRINT#2,"      LOGICAL FXOR"
  274. 14150 IF IMPFLG THEN PRINT#2,"      LOGICAL FIMP":PRINT#2,"      FIMP(X,Y)=((X .AND. Y) .OR. ((.NOT. X) .AND. Y))"
  275. 14200 IF XORFLG THEN PRINT#2,"      FXOR(X,Y)=((X .OR Y) .AND. (.NOT. (X .AND. Y)))"
  276. 14250 IF EQVFLG THEN PRINT#2,"      FEQV(X,Y)=((X .AND. Y) .OR. (.NOT. X) .AND. (.NOT. Y))
  277. 14300 RETURN
  278. 14350 L=LEN(BUF$(0))
  279. 14400 GOSUB 11100
  280. 14450 FOR IT=1 TO TP
  281. 14451 RW=CSRLIN:CL=POS(0)
  282. 14452 LOCATE 25,1:PRINT SPACE$(78);
  283. 14453 LOCATE 25,1:COLOR 6,0:PRINT MID$(BUF$(0),7);:LOCATE 25,70:COLOR 2,0:PRINT       TIME$;
  284. 14454 LOCATE RW,CL
  285. 14500 A=AA(IT):B=BB(IT):TOKEN$=TOKLST$(IT):P=PTLST(IT)
  286. 14550 IF TOKEN$<>KBAS$(P) THEN S=0:GOTO 18200
  287. 14600 IF P>23 THEN 14800
  288. 14650 REM 1 TO 23
  289. 14700 ON P GOSUB 21800,15250,15250,15250,15300,15250,15250,15250,19000,           15350,15200,15200,15250,15250,15150,17750,17750,17750,15250,15250,15250,          15200,15200
  290. 14750 GOTO 15650
  291. 14800 IF P>57 THEN 15000
  292. 14850 REM 24 TO 57
  293. 14900 ON P-23 GOSUB 21800,15200,15250,15150,15950,15200,17250,19200,21600,          15200,15250,15400,15200,15200,15150,15250,15200,21750,19050,15250,17350,          16350,15200,15250,15250,17850,15200,15200,15200,15200,15250,15200,15200,          15200
  294. 14950 GOTO 15650
  295. 15000 IF P>71 THEN ERROR 89
  296. 15050 ON P-57 GOSUB 15250,15250,15200,18300,15200,15250,15800,15250,15200,          18600,19050,15250,17850,21700
  297. 15100 GOTO 15650
  298. 15150 BUF$(0)=FNREP$(BUF$(0),"",A,B):RETURN
  299. 15200 RETURN
  300. 15250 BUF$(0)=FNREP$(BUF$(0),KFOR$(P),A,B):RETURN
  301. 15300 BUF$(0)=LEFT$(BUF$(0),6)+"WRITE(*,*) CHAR(7)":RETURN
  302. 15350 REM CLS:RETURN
  303. 15400 REM INPUT#
  304. 15450 Q$=MID$(BUF$(0),B):X=VAL(MID$(BUF$(0),B)):BUF$(0)=MID$(BUF$(0),A,B-1)+         "READ("
  305. 15500 X$=STR$(X):BUF$(0)=BUF$(0)+X$+")"+Q$:RETURN
  306. 15550 REM WRITE#
  307. 15600 RETURN
  308. 15650 NEXT IT
  309. 15700 GOSUB 20900
  310. 15750 RETURN
  311. 15800 X$=KFOR$(P)+CHR$(13)+CHR$(10)+"      "
  312. 15850 IF FNUM(MID$(BUF$(0),B+1)) THEN X$=X$+"GOTO "
  313. 15900 BUF$(0)=FNREP$(BUF$(0),X$,A,B):RETURN
  314. 15950 REM FOR
  315. 16000 IF MID$(BUF$(0),FC,4)="OPEN" THEN RETURN
  316. 16050 FOR J=1 TO PT4:K=J:IF POINT4!(J,1)=LINEO! THEN 16200
  317. 16100 NEXT J
  318. 16150 PRINT"error":STOP
  319. 16200 X$=STR$(POINT4!(K,2)):X$="DO"+X$
  320. 16250 BUF$(0)=FNREP$(BUF$(0),X$,A,B)
  321. 16300 RETURN
  322. 16350 ACC$=",ACCESS="+CHR$(34)+"SEQUENTIAL"+CHR$(34):RL$=""
  323. 16400 IF INSTR(BUF$(0),",")<>0 THEN 16850
  324. 16450 FS=INSTR(FC,BUF$(0)," "):X=INSTR(FS+1,BUF$(0)," ")
  325. 16500 X$=MID$(BUF$(0),FS+1,X-FS-1)
  326. 16550 P3=INSTR(BUF$(0),"#"):IF P3=0 THEN P3=INSTR(BUF$(0)," AS ")+3
  327. 16600 FIL=VAL(MID$(BUF$(0),P3+1))
  328. 16650 P4=INSTR(BUF$(0),"="):IF P4=0 THEN 16750
  329. 16700 RL$=",RECL="+STR$(VAL(MID$(BUF$(0),P4+1))):ACC$=",ACCESS="+CHR$(34)+            "DIRECT"+CHR$(34)
  330. 16750 BUF$(0)="      OPEN("+STR$(FIL)+",FILE="+X$+",STATUS="+CHR$(34)+"OLD"+        CHR$(34)+ACC$+RL$+")"
  331. 16800 RETURN
  332. 16850 P1=INSTR(FC,BUF$(0),","):P2=INSTR(P1+1,BUF$(0),",")
  333. 16900 P3=INSTR(P2+1,BUF$(0),","):IF P3=0 THEN P3=LEN(BUF$(0))
  334. 16950 X$=MID$(BUF$(0),P2+1,P3-P2-1)
  335. 17000 P4=INSTR(BUF$(0),"#"):IF P4=0 THEN P4=P1
  336. 17050 FIL=VAL(MID$(BUF$(0),P4+1))
  337. 17100 IF P3<LEN(BUF$(0)) THEN RL$=",RECL="+STR$(VAL(MID$(BUF$(0),P3+1))):ACC$=        ",ACCESS="+CHR$(34)+"DIRECT"+CHR$(34)
  338. 17150 GOTO 16750
  339. 17200 RETURN
  340. 17250 REM GOTO
  341. 17300 RETURN
  342. 17350 REM ON
  343. 17400 BL(1)=INSTR(FC,BUF$(0)," ")
  344. 17450 FOR M=2 TO 3:BL(M)=INSTR(BL(M-1)+1,BUF$(0)," "):NEXT
  345. 17500 IF MID$(BUF$(0),BL(2)+1,BL(3)-BL(2)-1)<>"GOTO" THEN RETURN
  346. 17550 X$=MID$(BUF$(0),BL(1)+1,BL(2)-BL(1)-1)
  347. 17600 Y$="("+MID$(BUF$(0),BL(3)+1)+") "
  348. 17650 BUF$(0)="      GOTO "+Y$+X$:RETURN
  349. 17700 RETURN
  350. 17750 REM DEF---
  351. 17800 GOSUB 15250:BUF$(0)=BUF$(0)+")":RETURN
  352. 17850 REM PRINT#
  353. 17900 P2=INSTR(BUF$(0),","):P1=INSTR(BUF$(0),"#"):FIL$=STR$(VAL(MID$(BUF$(0),         P1+1,P2-P1-1)))
  354. 17950 FIL$=MID$(FIL$,2)
  355. 18000 BUF$(0)=FNREP$(BUF$(0),"WRITE("+FIL$+",*)",FC,P2+1)
  356. 18050 RETURN
  357. 18100 REM
  358. 18150 RETURN
  359. 18200 REM SPECIAL ACTION
  360. 18250 GOTO 15650
  361. 18300 P1=INSTR(FC,BUF$(0)," "):P2=INSTR(BUF$(0),",")
  362. 18350 X$=MID$(BUF$(0),P1+1,P2-P1-1):Y$=MID$(BUF$(0),P2+1)
  363. 18400 Z$="TEMP$$="+X$+CHR$(13)+CHR$(10)+"      "+X$+"="+Y$
  364. 18450 Z$=Z$+CHR$(13)+CHR$(10)+"      "+Y$+"="+"TEMP$$"
  365. 18500 BUF$(0)=LEFT$(BUF$(0),6)+Z$:RETURN
  366. 18550 RETURN
  367. 18600 REM WEND
  368. 18650 BUF$(0)=FNREP$(BUF$(0),"IF(",A,B):GOSUB 19300
  369. 18700 FOR J=1 TO PT4:K=J:IF POINT4!(J,2)=LINEO! THEN 18850
  370. 18750 NEXT J
  371. 18800 PRINT"ERROR":STOP
  372. 18850 X$=STR$(POINT4!(K,1))
  373. 18900 BUF$(0)=BUF$(0)+")"+" GOTO "+X$
  374. 18950 RETURN
  375. 19000 GOSUB 15250:BUF$(0)=BUF$(0)+")":RETURN
  376. 19050 BUF$(0)=LEFT$(BUF$(0),6)+"CONTINUE"
  377. 19150 I=0:GOSUB 20850:RETURN
  378. 19200 REM
  379. 19250 GOSUB 15250:IFFLG=TRUE
  380. 19300 M=0:X=INSTR(BUF$(0),"ELSE"):IF X=0 THEN X=LEN(BUF$(0))
  381. 19350 M=M+1:IF M>X THEN 20750
  382. 19400 IF MID$(BUF$(0),M,1)="]" THEN IFFLG=FALSE:MID$(BUF$(0),M,1)=")"
  383. 19450 P=INSTR("<>=",MID$(BUF$(0),M,1))
  384. 19500 IF MID$(BUF$(0),M,3)="IF(" THEN IFFLG=TRUE
  385. 19550 IF P=0 OR NOT IFFLG THEN 19350
  386. 19600 MM=M+1
  387. 19650 Q=INSTR("<>=",MID$(BUF$(0),MM,1)):IF Q=0 THEN MM=M
  388. 19700 R=4*Q+P:ON R+1 GOTO 20650,19750,19900,20050,20650,20650,20200,20350,20650,      20200,20650,20500,20650,20350,20500,20650
  389. 19750 REM <
  390. 19800 BUF$(0)=FNREP$(BUF$(0),".LT.",M,MM+1)
  391. 19850 M=MM+2:GOTO 19400
  392. 19900 REM >
  393. 19950 BUF$(0)=FNREP$(BUF$(0),".GT.",M,MM+1)
  394. 20000 M=MM+2:GOTO 19400
  395. 20050 REM =
  396. 20100 BUF$(0)=FNREP$(BUF$(0),".EQ.",M,MM+1)
  397. 20150 M=MM+2:GOTO 19400
  398. 20200 REM <>
  399. 20250 BUF$(0)=FNREP$(BUF$(0),".NE.",M,MM+1)
  400. 20300 M=MM+2:GOTO 19400
  401. 20350 REM <=
  402. 20400 BUF$(0)=FNREP$(BUF$(0),".LE.",M,MM+1)
  403. 20450 M=MM+2:GOTO 19400
  404. 20500 REM >=
  405. 20550 BUF$(0)=FNREP$(BUF$(0),".GE.",M,MM+1)
  406. 20600 M=MM+2:GOTO 19400
  407. 20650 REM IMPOSSIBLE...?
  408. 20700 GOTO 19400
  409. 20750 RETURN
  410. 20800 RETURN
  411. 20850 FOR NN=1 TO LEN(L$):MID$(BUF$(I),NN,1)=MID$(L$,NN,1):NEXT NN:RETURN
  412. 20900 REM SEARCH
  413. 20950 FOR J=1 TO IREF:K=J:IF REFLIN!(J)=LINEO! THEN 21100
  414. 21000 NEXT J
  415. 21050 RETURN
  416. 21100 I=0:GOSUB 20850:RETURN
  417. 21150 REM FINAL SCAN
  418. 21200 L=LEN(BUF$(0))
  419. 21250 I=0
  420. 21300 I=I+1:IF I>L THEN 21550
  421. 21350 X$=MID$(BUF$(0),I,1)
  422. 21400 IF X$=CHR$(34) THEN MID$(BUF$(0),I,1)="'" ELSE IF X$="^" THEN BUF$(0)=          FNREP$(BUF$(0),"**",I,I+1)
  423. 21450 L=LEN(BUF$(0))
  424. 21500 GOTO 21300
  425. 21550 RETURN
  426. 21600 REM IMP
  427. 21650 FUN$=" IMP":FUN2$="FIMP(":GOSUB 21850:RETURN
  428. 21700 FUN$=" XOR":FUN2$="FXOR(":GOSUB 21850:RETURN
  429. 21750 FUN$=" MOD":FUN2$="AMOD(":GOSUB 21850:RETURN
  430. 21800 FUN$=" EQV":FUN2$="FEQV(":GOSUB 21850:RETURN
  431. 21850 REM general
  432. 21900 P=INSTR(BUF$(0),FUN$)
  433. 21950 Y$="":FOR I=P-1 TO 1 STEP -1:X$=MID$(BUF$(0),I,1)
  434. 22000 IF(INSTR("=, +*/\()^:<>;-",X$)<>0) THEN 22100
  435. 22050 Y$=X$+Y$:NEXT I
  436. 22100 R=P+5:FOR Q=R TO LEN(BUF$(0)):X$=MID$(BUF$(0),Q,1)
  437. 22150 IF(INSTR("=, +*/\()^:<>;-",X$)<>0) THEN 22250
  438. 22200 NEXT Q
  439. 22250 X$=")":Z$=MID$(BUF$(0),R,Q-R+1):IF Z$="(" THEN Z$="":X$=""
  440. 22300 BUF$(0)=FNREP$(BUF$(0),FUN2$+Y$+","+Z$+X$,I+1,Q):RETURN
  441. 30000 LOCATE 3,50:COLOR 4,0:PRINT"SOURCE LINES:";Z!
  442. 30001 LOCATE 4,50:COLOR 6,0:PRINT"OUTPUT LINES:";OLIN
  443. 30002 RETURN
  444.